////////////////////////////////////////////////////////////////////////////
// PaxCompiler
// Site: http://www.paxcompiler.com
// Author: Alexander Baranovsky (paxscript@gmail.com)
// ========================================================================
// Copyright (c) Alexander Baranovsky, 2006-2011. All rights reserved.
// Code Version: 3.1
// ========================================================================
// Unit: PAXCOMP_BASIC_SCANNER.pas
// ========================================================================
////////////////////////////////////////////////////////////////////////////

{$I PaxCompiler.def}
unit PAXCOMP_BASIC_SCANNER;
interface
uses
  SysUtils,
  PAXCOMP_CONSTANTS,
  PAXCOMP_SYS,
  PAXCOMP_SCANNER,
  PAXCOMP_BYTECODE;

type
  TBasicScanner = class(TBaseScanner)
  private
    function Scan_LogicalXORExpression: Variant;
    function Scan_LogicalORExpression: Variant;
    function Scan_LogicalANDExpression: Variant;
    function Scan_LogicalNOTExpression: Variant;
    function Scan_RelationalExpression: Variant;
    function Scan_ShiftExpression: Variant;
    function Scan_ConcatenationExpression: Variant;
    function Scan_AdditiveExpression: Variant;
    function Scan_ModulusExpression: Variant;
    function Scan_IntegerDivisionExpression: Variant;
    function Scan_MultiplicativeExpression: Variant;

    procedure ScanCondDir;
    procedure ScanCustDir;
  public
    function Scan_Expression: Variant; override;
    function Scan_Ident: Variant; override;
    procedure ReadCustomToken; override;
  end;

implementation

uses
  PAXCOMP_KERNEL;

procedure TBasicScanner.ReadCustomToken;
var
  c: Char;
begin
  repeat
    GetNextChar;
    c := LA(0);
    Token.Position := Position;
    if IsWhiteSpace(c) then
    begin
      continue;
    end
    else if c = #13 then
      ScanSeparator
    else if c = #10 then
      ScanSeparator
    else if IsEOF(c) then
      ScanSpecial
    else if IsEOF then
      ScanEOF
    else if IsAlpha(c) then
      ScanIdentifier
    else if IsDigit(c) then
      ScanNumberLiteral
    else if c = '$' then
      ScanHexLiteral
    else if c = CHAR_DOUBLE_AP then
      ScanStringLiteral(CHAR_DOUBLE_AP)
    else if c = CHAR_AP then
    begin
      ScanSingleLineComment();
  		continue;
    end
    else if c = '+' then
    begin
      ScanSpecial;
      if LA(1) = '=' then
      begin
        GetNextChar;
        ScanSpecial;
      end;
      Token.Id := OP_PLUS;
    end
    else if c = '-' then
    begin
      ScanSpecial;
      if LA(1) = '=' then
      begin
        GetNextChar;
        ScanSpecial;
      end;
      Token.Id := OP_MINUS;
    end
    else if c = '*' then
    begin
      ScanSpecial;
      if LA(1) = '=' then
      begin
        GetNextChar;
        ScanSpecial;
      end;
      Token.Id := OP_MULT;
    end
    else if c = '/' then
    begin
      if LA(1) = '/' then
      begin
        ScanSingleLineComment();
				continue;
      end
      else
      begin
        ScanSpecial;
        if LA(1) = '=' then
        begin
          GetNextChar;
          ScanSpecial;
        end;
        Token.Id := OP_DIV;
      end;
    end
    else if c = '\' then
    begin
      ScanSpecial;
      if LA(1) = '=' then
      begin
        GetNextChar;
        ScanSpecial;
      end;
      Token.Id := OP_IDIV;
    end
    else if c = '=' then
    begin
      ScanSpecial;
      Token.Id := OP_EQ;
      if LA(1) = '>' then
      begin
        GetNextChar;
        ScanSpecial;
      end;
    end
    else if c = '<' then
    begin
      ScanSpecial;
      if LA(1) = '=' then
      begin
        GetNextChar;
        ScanSpecial;
        Token.Id := OP_LE;
      end
      else if LA(1) = '>' then
      begin
        GetNextChar;
        ScanSpecial;
        Token.Id := OP_NE;
      end
      else if LA(1) = '<' then
      begin
        GetNextChar;
        ScanSpecial;
        Token.Id := OP_SHL;
      end
      else
        Token.Id := OP_LT;
    end
    else if c = '>' then
    begin
      ScanSpecial;
      if LA(1) = '=' then
      begin
        GetNextChar;
        ScanSpecial;
        Token.Id := OP_GE;
      end
      else if LA(1) = '>' then
      begin
        GetNextChar;
        ScanSpecial;
        Token.Id := OP_SHR;
      end
      else
        Token.Id := OP_GT;
    end
    else if c = ':' then
    begin
      ScanSpecial;
      if LA(1) = '=' then
      begin
        GetNextChar;
        ScanSpecial;
        Token.Id := OP_ASSIGN;
      end;
    end
    else if c = ',' then
      ScanSpecial
    else if c = '.' then
      ScanSpecial
    else if c = '(' then
      ScanSpecial
    else if c = ')' then
      ScanSpecial
    else if c = '[' then
      ScanSpecial
    else if c = ']' then
      ScanSpecial
    else if c = '{' then
      ScanSpecial
    else if c = '}' then
      ScanSpecial
    else if c = '^' then
      ScanSpecial
    else if c = ':' then
      ScanSpecial
    else if c = ';' then
      ScanSpecial
    else if c = '#' then
    begin
      ScanCondDir;
      Token.TokenClass := tcNone;
      continue;
    end
    else if c = '@' then
    begin
      ScanCustDir;
      Token.TokenClass := tcNone;
      continue;
    end
    else if c = '&' then
    begin
      c := LA(1);
      if CharInSet(c, ['h','H']) then
      begin
        GetNextChar;
        ScanHexLiteral;
      end
      else
        ScanSpecial;
    end
    else
      RaiseError(errSyntaxError, []);
  until Token.TokenClass <> tcNone;
end;

procedure TBasicScanner.ScanCustDir;
label
  NextComment, Fin;
const
  IdsSet = ['a'..'z','A'..'Z','0'..'9','_', '\', '/', '"'];
  Start1 = '@';
var
  S: String;
  DirName: String;
  ok: Boolean;
begin
  DirName := '';

  S := '';
  repeat
   GetNextChar;
   if CharInSet(LA(0), [#10,#13]) then
   begin
    Inc(LineCount);
    GenSeparator;

    if LA(0) = #13 then
      GetNextChar;
   end
   else
    S := S + LA(0);
  until not CharInSet(LA(0), IdsSet);


  ScanChars(['A'..'Z', 'a'..'z', '0'..'9', '_', '.', '-', '[', ']', '(', ')',
   ',', '\', '/', '"', ' ', ':']);

  DirName := s + Token.Text;

  with TKernel(kernel) do
   if Assigned(OnUnknownDirective) then
   begin
    ok := true;
    OnUnknownDirective(Owner, DirName, ok);
    if not ok then
      Self.RaiseError(errInvalidCompilerDirective, [DirName]);
   end;

  ScanChars(WhiteSpaces);
  GenSeparator;
end;

procedure TBasicScanner.ScanCondDir;
label
  NextComment, Fin;
const
  IdsSet = ['a'..'z','A'..'Z','0'..'9','_'];
  Start1 = '#';
var
  S: String;
  I, J, J1, J2: Integer;
  Visible: Boolean;
  DirName: String;
  ok: Boolean;
  value: Variant;
begin
  DirName := '';

  Visible := true;

NextComment:

  S := '';
  repeat
    GetNextChar;
    if CharInSet(LA(0), [#10,#13]) then
    begin
      Inc(LineCount);
      GenSeparator;

      if LA(0) = #13 then
        GetNextChar;
    end
    else
      S := S + LA(0);
  until not CharInSet(LA(0), IdsSet);

  I := Pos('CONST ', UpperCase(S) + ' ');
  if I > 0 then
  begin
    while not CharInSet(LA(0), IdsSet) do
      GetNextChar;

    ScanChars(['A'..'Z', 'a'..'z', '0'..'9', '_', '.', '-', '[', ']', '(', ')', ',']);

    DirName := Token.Text;

    ScanChars(WhiteSpaces);

    if LA(1) = '=' then
    begin
      ScanChars(['=', ' ']);
      ReadToken;
      value := Scan_Expression;
    end;

    TKernel(kernel).DefList.Add(DirName, value);

    with TKernel(kernel) do
      if Assigned(OnDefineDirective) then
      begin
        ok := true;
        OnDefineDirective(Owner, DirName, ok);
        if not ok then
          Self.RaiseError(errInvalidCompilerDirective, [DirName]);
      end;

    ScanChars(WhiteSpaces);
    GenSeparator;
    Exit;
  end;

  I := Pos('IF ', UpperCase(S) + ' ');

  if I = 1 then
  begin
    ScanChars(WhiteSpaces);
    ReadToken;
    value := Scan_Expression;
    if value then
      Visible := DefStack.OuterVis
    else
      Visible := false;
    Match('Then');

    DefStack.Push(_IFDEF, '', Visible);

    ScanChars(WhiteSpaces);
    if not Visible then
      GenSeparator;
    goto Fin;
  end;

  I := Pos('ELSEIF ', UpperCase(S) + ' ');
  if I = 1 then
  begin
    ScanChars(WhiteSpaces);
    ReadToken;
    value := Scan_Expression;
    if value then
      Visible := DefStack.OuterVis
    else
      Visible := false;
    Match('Then');

  	if DefStack.Count = 0 then
      Self.RaiseError(errInvalidCompilerDirective, ['ElseIf']);

    if not DefStack.Top.Word in [_IFDEF, _ELSEIF] then
      Self.RaiseError(errInvalidCompilerDirective, ['ElseIf']);

    for J:=DefStack.Count - 1 downto 0 do
    begin
      if DefStack[J].Vis then
      begin
        Visible := false;
        Break;
      end;
      if DefStack[J].Word = _IFDEF then
        break;
    end;

    DefStack.Push(_ELSEIF, '', Visible);

    ScanChars(WhiteSpaces);
    if not Visible then
      GenSeparator;
    goto Fin;
  end;

  I := Pos('ELSE ', UpperCase(S) + ' ');
  if I = 1 then
  begin
    ScanChars(WhiteSpaces);

    if DefStack.Count = 0 then
      Self.RaiseError(errInvalidCompilerDirective, ['']);

    Visible := DefStack.OuterVis;

    if DefStack.Top.Word in [_IFDEF, _ELSEIF] then
    begin
      for J:=DefStack.Count - 1 downto 0 do
      begin
        if DefStack[J].Vis then
        begin
          Visible := false;
          Break;
        end;
        if DefStack[J].Word = _IFDEF then
          break;
      end;

    end
    else
      Self.RaiseError(errInvalidCompilerDirective, ['']);

    DefStack.Push(_ELSE, '', Visible);

    ScanChars(WhiteSpaces);
    if not Visible then
      GenSeparator;
    goto Fin;
  end;

  I := Pos('END ', UpperCase(S) + ' ');

  if I = 1 then
  begin
    ScanChars(WhiteSpaces);

    J1 := 0;
    J2 := 0;
    for I := DefStack.Count - 1 downto 0 do
      if DefStack[I].Word in [_IFDEF, _IFNDEF] then
        Inc(J1)
      else if DefStack[I].Word = _ENDIF then
        Inc(J2);
    if J2 >= J1 then
      Self.RaiseError(errInvalidCompilerDirective, ['']);

    for I:=DefStack.Count - 1 downto 0 do
      if DefStack[I].Word in [_IFDEF, _IFNDEF] then
      begin
        while DefStack.Count > I do
          DefStack.Pop;
        Break;
      end;

    if DefStack.Count = 0 then
      Visible := true
    else
      Visible := DefStack[DefStack.Count - 1].Vis;

    ReadToken;
    Match('If');

    ScanChars(WhiteSpaces);
    if not Visible then
      GenSeparator;

    goto Fin;
  end;

  DirName := S;

  while not CharInSet(LA(0), ['a'..'z','A'..'Z','0'..'9','_', '\', '/', '"']) do
    GetNextChar;

 ScanChars(['A'..'Z', 'a'..'z', '0'..'9', '_', '.', '-', '[', ']', '(', ')', ',', '\', '/', '"']);

 DirName := s + Token.Text;

 ok := False;

  with TKernel(kernel) do
    if Assigned(OnUnknownDirective) then
    begin
      OnUnknownDirective(Owner, DirName, ok);
      if not ok then
        Self.RaiseError(errInvalidCompilerDirective, [DirName]);
      ScanChars(WhiteSpaces);
    end
  else
    Self.RaiseError(errInvalidCompilerDirective, [DirName]);

Fin:

  if not Visible then
  begin

    repeat
      GetNextChar;
      if CharInSet(LA(0), [#10,#13]) then
      begin
        Inc(LineCount);
        GenSeparator;
        if LA(0) = #13 then
          GetNextChar;
      end;
    until (LA(0) = Start1) or IsEOF;

    if IsEOF then
      Self.RaiseError(errMissingENDIFdirective, []);

    goto NextComment;
  end;
end;

function TBasicScanner.Scan_Expression: Variant;
begin
  result := Scan_LogicalXORExpression;
end;

function TBasicScanner.Scan_LogicalXORExpression: Variant;
begin
	result := Scan_LogicalORExpression;
	while IsCurrText('Xor') do
  begin
		ReadToken;
		result := result xor Scan_LogicalORExpression;
	end;
end;

function TBasicScanner.Scan_LogicalORExpression: Variant;
begin
  result := Scan_LogicalANDExpression;
  while IsCurrText('Or') or IsCurrText('OrElse') do
  begin
    if IsCurrText('Or') then
    begin
      ReadToken;
      result := result or Scan_LogicalANDExpression;
    end
    else
    begin
      if result then
        Exit;
      result := Scan_LogicalANDExpression;
    end;
  end;
end;

function TBasicScanner.Scan_LogicalANDExpression: Variant;
begin
  result := Scan_LogicalNOTExpression;
  while IsCurrText('And') or IsCurrText('AndAlso') do
  begin
    if IsCurrText('And') then
    begin
      ReadToken;
      result := result and Scan_LogicalNOTExpression;
    end
    else
    begin
      if not result then
        Exit;
      result := Scan_LogicalNOTExpression;
    end;
  end;
end;

function TBasicScanner.Scan_LogicalNOTExpression: Variant;
begin
  if IsCurrText('Not') then
  begin
    Match('Not');
    result := not Scan_Expression;
  end
  else
    result := Scan_RelationalExpression;
end;

function TBasicScanner.Scan_RelationalExpression: Variant;
begin
  result := Scan_ShiftExpression;
  while IsCurrText('=') or IsCurrText('<>') or
        IsCurrText('>') or IsCurrText('>=') or
        IsCurrText('<') or IsCurrText('<=') do
  begin
    if IsCurrText('=') then
    begin
      ReadToken;
      result := result = Scan_ShiftExpression;
    end
    else if IsCurrText('<>') then
    begin
      ReadToken;
      result := result <> Scan_ShiftExpression;
    end
    else if IsCurrText('>') then
    begin
      ReadToken;
      result := result > Scan_ShiftExpression;
    end
    else if IsCurrText('>=') then
    begin
      ReadToken;
      result := result >= Scan_ShiftExpression;
    end
    else if IsCurrText('<') then
    begin
      ReadToken;
      result := result < Scan_ShiftExpression;
    end
    else if IsCurrText('<=') then
    begin
      ReadToken;
      result := result <= Scan_ShiftExpression;
    end;
  end
end;

function TBasicScanner.Scan_ShiftExpression: Variant;
begin
  result := Scan_ConcatenationExpression;
  while IsCurrText('<<') or IsCurrText('>>') do
  begin
    if IsCurrText('<<') then
    begin
      ReadToken;
      result := result shl Scan_ConcatenationExpression;
    end
    else
    begin
      ReadToken;
      result := result shr Scan_ConcatenationExpression;
    end;
  end;
end;

function TBasicScanner.Scan_ConcatenationExpression: Variant;
begin
  result := Scan_AdditiveExpression;
  while IsCurrText('&') do
  begin
    ReadToken;
    result := result + Scan_AdditiveExpression;
  end;
end;

function TBasicScanner.Scan_AdditiveExpression: Variant;
begin
  result := Scan_ModulusExpression;
  while IsCurrText('+') or IsCurrText('-') do
  begin
    if IsCurrText('+') then
    begin
      ReadToken;
      result := result + Scan_ModulusExpression;
    end
    else
    begin
      ReadToken;
      result := result - Scan_ModulusExpression;
    end;
  end;
end;

function TBasicScanner.Scan_ModulusExpression: Variant;
begin
  result := Scan_IntegerDivisionExpression;
  while IsCurrText('Mod') do
  begin
    ReadToken;
    result := result Mod Scan_IntegerDivisionExpression;
  end;
end;

function TBasicScanner.Scan_IntegerDivisionExpression: Variant;
begin
  result := Scan_MultiplicativeExpression;
  while IsCurrText('\') do
  begin
    ReadToken;
    result := result div Scan_MultiplicativeExpression;
  end;
end;

function TBasicScanner.Scan_MultiplicativeExpression: Variant;
begin
  result := Scan_Factor;
  while IsCurrText('*') or IsCurrText('/') do
  begin
    if IsCurrText('*') then
    begin
      ReadToken;
      result := result * Scan_Factor;
    end
    else
    begin
      ReadToken;
      result := result / Scan_Factor;
    end;
  end;
end;

function TBasicScanner.Scan_Ident: Variant;
var
  I: Integer;
  DefList: TDefList;
begin
  DefList := TKernel(kernel).DefList;
  I := DefList.IndexOf(Token.Text);
  if I = -1 then
     RaiseError(errInvalidCompilerDirective, [Token.Text]);
  result := DefList[I].value;
  ReadToken;
end;

end.
